home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / ED.S < prev    next >
Encoding:
Text File  |  1993-11-08  |  70.6 KB  |  2,104 lines
  1. ;************************************************************************
  2. ;*                                    *
  3. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  4. ;*                                    *
  5. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  6. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  7. ;*                                    *
  8. ;*----------------------------------------------------------------------*
  9. ;*                                    *
  10. ;*    A small adaptative text & scheme editor generator        *
  11. ;*                                    *
  12. ;*----------------------------------------------------------------------*
  13. ;*                                    *
  14. ;* Created by: Marc Vuilleumier        Date: Jan 1993            *
  15. ;* Revision history:                            *
  16. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  17. ;*                                    *
  18. ;*                    ``In nomine omnipotentii dei''    *
  19. ;************************************************************************
  20. ; Note: this code contains too much lexical variables to be compiled 
  21. ;       with the debugging information. Use (SET! PCS-DEBUG-MODE #F)
  22.  
  23. (begin
  24.   (define make-editor)
  25.   (define make-enhanced-editor)
  26.   (define make-color-editor)
  27.   (define make-scheme-editor)
  28.   (define editor-handle-exit)
  29. )
  30.  
  31. (let                    ; values shared by all editors
  32.   ((fill                 ; tab expansion char
  33.      (integer->char 255))
  34.    (special-keys            ; special escape keys
  35.      '(0))
  36.    (action-keys
  37.      (list
  38.        (cons (list* 072 000) '@up)
  39.        (cons (list* 075 000) '@left)
  40.        (cons (list* 077 000) '@right)
  41.        (cons (list* 080 000) '@down)
  42.        (cons (list* 073 000) '@page-up)
  43.        (cons (list* 081 000) '@page-down)
  44.        (cons (list* 071 000) '@home)
  45.        (cons (list* 079 000) '@end)
  46.        (cons (list* 132 000) '@top-of-buffer)
  47.        (cons (list* 118 000) '@end-of-buffer)
  48.        (cons (list* 034 000) '@goto-line)        ; Alt-G
  49.        (cons (list*     008) '@backspace)
  50.        (cons (list* 083 000) '@del)
  51.        (cons (list* 032 000) '@delete-line)      ; Alt-D
  52.        (cons (list* 037 000) '@delete-to-eol)    ; Atl-K
  53.        (cons (list* 023 000) '@insert)        ; Alt-I
  54.        (cons (list* 115 000) '@word-left)
  55.        (cons (list* 116 000) '@word-right)
  56.        (cons (list*     009) '@tab)
  57.        (cons (list*     013) '@enter)
  58.        (cons (list* 013 000) '@enter)         ; Grey enter key
  59.        (cons (list* 016 000) '@quote)        ; Alt-Q
  60.        (cons (list*     012) '@refresh)          ; Ctrl-L: Refresh
  61.        (cons (list* 017 000) '@write)         ; Alt-W: Write file
  62.        (cons (list* 018 000) '@load)          ; Alt-E: Edit another file
  63.        (cons (list* 019 000) '@read-into)        ; Alt-R: Read into current
  64.        (cons (list* 024 000) '@rename)      ; Alt-O: New Output name
  65.        (cons (list* 045 000) '@exit)          ; Alt-X: Exit
  66.        (cons (list* 065 000) '@record)        ; F7
  67.        (cons (list* 066 000) '@play)            ; F8
  68.        (cons (list* 068 000) '@execute)      ; F10
  69.      ))
  70.   )
  71.  
  72.   (set! make-editor 
  73.     (lambda param
  74.       (letrec
  75.         ((input-port (if (port? (car param)) (car param) 'console))
  76.          (win #F)                ; Output port or #f for blind editor
  77.          (nest 0)                ; Nesting level
  78.          (attr 7)                ; Attribute for normal text
  79.          (nlin 0)                ; Number of lines/cols
  80.          (ncol 0)
  81.          (flin 1)                ; First line/col displayed, last col
  82.          (fcol 0)
  83.          (lcol 0) 
  84.          (clin 1)                ; Current line/col
  85.          (ccol 0)
  86.          (dim (cons nlin ncol))        ; Window size
  87.          (todo #F)                ; Top-level action to do when possible
  88.          (buffer (list "" ""))        ; The Buffer and its name
  89.          (name (list "NONAME.S"))        ; A pair: name and saved status-line
  90.          (keys "")
  91.          (modified #F)            ; Modified? (need to save)
  92.          (drty #F)                ; Dirty? (need screen update)
  93.          (mmov #F)                ; Magic move? (redraw line)
  94.          (recd #F)                    ; Recording ?
  95.          (tab 8)                ; Tab expansion length
  96.          (tabulize-mode 'NORMAL)             ; Tab compression mode
  97.          (insert #T)            ; Insert mode flag
  98.          (bkp #T)                ; Backup when saving flag
  99.          (status-window pcs-status-window)    ; Window for status line
  100.          (separators             ; Characters splitting two words
  101.        (list->string (list #\space fill)))
  102.                     
  103.          (magic (lambda (line)
  104.        (when win
  105.          (if (= line clin) (disppos))
  106.          (when (eq? mmov 'hard)
  107.            (window-set-attribute! win 'text-attributes attr)
  108.            (window-scroll-up win (- line flin) (- line flin -1)))
  109.          (if mmov (write-line win (list-ref buffer line) flin line fcol lcol)))))
  110.  
  111.    ; Key handling
  112.  
  113.          (@up (lambda ()
  114.            (when (> clin 1)
  115.              (when (and win (= flin clin))
  116.            (set! flin (-1+ flin))
  117.            (window-set-attribute! win 'text-attributes attr)
  118.            (window-scroll-down win)
  119.            (let ((str (list-ref buffer flin)))
  120.              (write-line win str flin flin fcol lcol)))
  121.              (set! clin (-1+ clin))
  122.          (magic (1+ clin))
  123.          (magic clin))
  124.            ))
  125.  
  126.          (@left (lambda ()
  127.            (when (> ccol 0)
  128.              (set! ccol (-1+ ccol))
  129.              (if (and win (> fcol 0) (< (- ccol fcol) 8))
  130.              (begin (set! fcol (- fcol 10))
  131.                 (set! lcol (- lcol 10))
  132.                 (@refresh))
  133.              (magic clin)))
  134.            ))
  135.  
  136.          (@right (lambda ()
  137.            (set! ccol (1+ ccol))
  138.            (if (and win (= lcol ccol))
  139.            (begin (set! fcol (+ fcol 10))
  140.               (set! lcol (+ lcol 10))
  141.               (@refresh))
  142.            (magic clin))
  143.            ))
  144.  
  145.          (@down (lambda ()
  146.            (when (pair? (list-tail buffer (1+ clin)))
  147.              (when (and win (= (1+ clin) (+ flin nlin)))
  148.            (set! flin (1+ flin))
  149.            (window-set-attribute! win 'text-attributes attr)
  150.            (window-scroll-up win)
  151.            (displl))
  152.              (set! clin (1+ clin))
  153.          (magic (-1+ clin))
  154.          (magic clin))
  155.            ))
  156.  
  157.          (@page-up (lambda ()
  158.            (set! clin (max (1+ (- clin nlin)) 1))
  159.            (set! flin (max (1+ (- flin nlin)) 1))
  160.            (@refresh)))
  161.  
  162.          (@page-down (lambda ()
  163.            (set! clin (-1+ (min (+ clin nlin) (length buffer))))
  164.            (set! flin
  165.                  (min (-1+ (+ flin nlin)) (max 1 (- (length buffer) nlin))))
  166.            (@refresh)))
  167.  
  168.          (@home (lambda ()
  169.            (set! ccol 0)
  170.            (if (> fcol 0)
  171.            (begin (set! fcol 0)
  172.               (set! lcol ncol)
  173.               (@refresh))
  174.            (magic clin))
  175.            ))
  176.  
  177.          (@end (lambda ()
  178.            (set! ccol (string-length (list-ref buffer clin)))
  179.            (set! fcol (max 0 (1+ (- ccol ncol))))
  180.            (if (not (= lcol (+ fcol ncol)))
  181.            (begin (set! lcol (+ fcol ncol))
  182.               (@refresh))
  183.            (magic clin))
  184.            ))
  185.  
  186.          (@top-of-buffer (lambda ()
  187.        (set! clin 1)
  188.        (set! flin 1)
  189.        (@refresh)))
  190.  
  191.          (@end-of-buffer (lambda ()
  192.        (set! clin (-1+ (length buffer)))
  193.        (checkp)))
  194.  
  195.          (@goto-line (lambda ()
  196.        (let* ((line clin)
  197.               (str (with-status
  198.                    (lambda (mes)
  199.                     (displayp "Go to line: " mes)
  200.                (read-linep mes)))))
  201.          (when (not (eqv? str ""))
  202.                (set! clin (string->number str))
  203.            (if (< clin 1) (set! clin 1))
  204.            (if (null? (list-tail buffer clin)) 
  205.            (set! clin (-1+ (length buffer))))
  206.            (checkp)))))
  207.  
  208.      (@backspace (lambda ()
  209.            (when (> ccol 0)
  210.              (let* ((curr (list-tail buffer clin))
  211.                     (len (string-length (car curr))))
  212.            (set! modified #T)
  213.                (set-car! curr
  214.                  (string-append
  215.                    (substring (car curr) 0 (min (-1+ ccol) len))
  216.                    (substring (car curr) (min ccol len) len)))
  217.                (@left)
  218.                (write-line win (string-append (car curr) " ") flin clin fcol lcol)))
  219.            ))
  220.  
  221.          (@del (lambda ()
  222.            (let* ((curr (list-tail buffer clin))
  223.                   (len (string-length (car curr)))
  224.               (rest (substring (car curr) (min ccol len) len)))
  225.          (set! modified #T)
  226.          (if (and (eqv? rest (make-string (string-length rest) #\space))
  227.               (cdr curr))
  228.            (begin
  229.              (set-car! curr 
  230.            (string-append
  231.              (substring (car curr) 0 (min ccol len))
  232.                  (make-string (max 0 (- ccol len)) fill)
  233.              (cadr curr)))
  234.              (set-cdr! curr (cddr curr))
  235.              (when win
  236.            (window-set-attribute! win 'text-attributes attr)
  237.            (window-scroll-up win (- clin flin -1))
  238.                  (displl)))
  239.                (set-car! curr
  240.                  (string-append
  241.            (substring (car curr) 0 (min ccol len))
  242.            (substring (car curr) (min (1+ ccol) len) len))))
  243.              (write-line win (string-append (car curr) " ") flin clin fcol lcol))
  244.            ))
  245.  
  246.          (@delete-to-eol (lambda ()
  247.        (let ((curr (list-tail buffer clin)))
  248.          (set-car! curr (substring (car curr) 0 
  249.                        (min ccol (string-length (car curr))))))
  250.        (refresh-line)))
  251.  
  252.          (@delete-line (lambda ()
  253.            (let ((curr (list-tail buffer (-1+ clin))))
  254.          (set! modified #T)
  255.          (set-cdr! curr (or (cddr curr) (if (= clin 1) (list ""))))
  256.          (when win 
  257.            (window-set-attribute! win 'text-attributes attr)
  258.            (window-scroll-up win (- clin flin)))
  259.          (if (null? (cdr curr)) 
  260.              (begin (set! clin (-1+ clin))
  261.                 (checkp))
  262.              (displl))
  263.          (magic clin))
  264.        ))
  265.  
  266.          (@insert (lambda ()
  267.            (set! insert (not insert))
  268.            ))
  269.  
  270.          (@word-left (lambda ()
  271.            (let ((str (list-ref buffer clin)))
  272.              (do ((new ccol (substring-find-previous-char-in-set str 0 (min ccol (string-length str)) separators)))
  273.                  ((or (null? new) (< new (-1+ ccol))) (set! ccol (if (null? new) 0 (1+ new))))
  274.                  (set! ccol new)))
  275.            (if (and (> fcol 0) (< (- ccol fcol) 8))
  276.            (begin (set! fcol (* 10 (min 0 (quotient (- ccol 8) 10))))
  277.               (set! lcol (+ fcol ncol))
  278.               (@refresh))
  279.            (magic clin))
  280.            ))
  281.  
  282.          (@word-right (lambda ()
  283.            (let* ((str (list-ref buffer clin))
  284.                   (len (string-length str)))
  285.              (set! ccol (substring-find-next-char-in-set str (min ccol len) len separators))
  286.              (if (null? ccol)
  287.                  (set! ccol len)
  288.                  (do ((new ccol (substring-find-next-char-in-set str (min ccol len) len separators)))
  289.                      ((or (null? new) (> new ccol)) '())
  290.                      (set! ccol (1+ new)))))
  291.            (if (>= ccol lcol)
  292.            (begin (set! fcol (* 10 (1+ (quotient (- ccol ncol) 10))))
  293.               (set! lcol (+ fcol ncol))
  294.               (@refresh))
  295.            (magic clin))
  296.            ))
  297.  
  298.      (@tab (lambda ()
  299.        (let ((ins insert))
  300.          (set! insert #t)
  301.          (insert-string (make-string (- tab (remainder ccol tab)) fill))
  302.          (set! insert ins))))
  303.  
  304.          (@enter (lambda ()
  305.        (when insert
  306.          (let* ((curr (list-tail buffer clin))
  307.             (str (car curr))
  308.             (len (string-length str))
  309.             (cut (min len ccol))
  310.             (line (- clin flin)))
  311.            (set! modified #T)
  312.            (set-car! curr (substring str 0 cut))
  313.            (set-cdr! curr (cons (substring str cut len) (cdr curr)))
  314.            (when win
  315.              (window-set-attribute! win 'text-attributes attr)
  316.              (window-scroll-down win (1+ line))
  317.              (when (< cut len)
  318.            (window-set-attribute! win 'text-attributes attr)
  319.                (window-scroll-down win line (1+ line))
  320.                (write-line win (car curr) flin clin fcol lcol))
  321.              (when (< (1+ line) nlin)
  322.            (write-line win (cadr curr) flin (1+ clin) fcol lcol)))))
  323.            (@down)
  324.        (@home)))
  325.  
  326.      (@quote (lambda ()
  327.        (let ((prev-actions actions)
  328.          (prev-specials specials))
  329.          (set! actions action-keys)
  330.          (set! specials special-keys)
  331.          (notify "Press a Basic-editor key...")
  332.          (set! actions prev-actions)
  333.          (set! specials prev-specials)
  334.        )))
  335.  
  336.      (@refresh (lambda ()
  337.        (if (char-ready? input-port)
  338.            (set! drty #t)
  339.            (when win
  340.              (set! drty #f)
  341.              (refresh-lines flin (+ flin nlin))))))
  342.  
  343.          (@write (lambda ()
  344.        (save (namep))
  345.        (notify "File " (namep) " written.")
  346.        ))
  347.  
  348.          (@load (lambda ()
  349.        (let* ((name (with-status
  350.               (lambda (mes)
  351.                 (displayp "Edit another file: " mes)
  352.                 (read-linep mes)))))
  353.          (when (not (eqv? name ""))
  354.                (safe)
  355.                (clear name)
  356.            (if (file-exists? name)
  357.                (loadp name))))
  358.        (@refresh)))
  359.  
  360.          (@read-into (lambda ()
  361.        (set! modified #T)
  362.        (let ((name (with-status
  363.              (lambda (mes)
  364.                (displayp "Read and insert file: " mes)
  365.                (read-linep mes)))))
  366.          (when (not (eqv? name ""))
  367.            (if (file-exists? name)
  368.                (loadp name))))
  369.        (@refresh)))
  370.  
  371.          (@rename (lambda ()
  372.        (let ((name (with-status
  373.              (lambda (mes)
  374.                (displayp "Give another name to buffer: " mes)
  375.                (read-linep mes)))))
  376.          (when (not (eqv? name ""))
  377.                (namep name)
  378.            (set! modified #T)))
  379.        ))
  380.  
  381.          (@exit (lambda ()
  382.            (set! todo 'exit)
  383.            ))
  384.  
  385.          (@record (lambda ()
  386.        (set! recd (not recd))
  387.        (if recd 
  388.            (set! keys "")
  389.            (let* ((rev (lambda (p) (cons (cdr p) (car p))))
  390.               (seq (cdr (assq '@record (map rev actions))))
  391.               (len (apply (lambda l (length l)) seq)))
  392.          (set! keys (substring keys 0 (- (string-length keys) len)))))
  393.        (notify (if recd 
  394.                "Recording keystroke macro" 
  395.                "Keystroke macro defined"))
  396.        ))
  397.  
  398.          (@play (lambda ()
  399.        (if recd
  400.            (let* ((rev (lambda (p) (cons (cdr p) (car p))))
  401.               (seq (cdr (assq '@play (map rev actions))))
  402.               (len (apply (lambda l (length l)) seq)))
  403.          (set! keys (substring keys 0 (- (string-length keys) len))))
  404.            (do-string keys))
  405.        ))
  406.  
  407.      (@execute (lambda ()
  408.        (let* ((f (open-input-string
  409.               (string-append
  410.             "("
  411.             (with-status
  412.               (lambda (mes)
  413.                 (displayp "Message: " mes)
  414.                 (read-linep mes)))
  415.             ")")))
  416.           (args (read f))
  417.           (result (if (assq (car args) jobs)
  418.                   (apply me args)
  419.                   #!unassigned)))
  420.          (handle-action
  421.            (with-status
  422.          (lambda (mes)
  423.            (when mes
  424.              (display "Result: " mes)
  425.              (write result mes)
  426.              (read-action))))))))
  427.  
  428.    ; main subfonctions
  429.             
  430.          (checkp (lambda ()        ; valid cursor/screen position
  431.        (let ((oldc fcol) (oldl flin))
  432.              (if (>= (- ccol fcol -2) ncol) (set! fcol (- ccol ncol -3)))
  433.              (if (>= (- clin flin -2) nlin) (set! flin (- clin nlin -3)))
  434.              (if (<= (- ccol fcol) 2) (set! fcol (max 0 (- ccol 2))))
  435.              (if (<= (- clin flin) 2) (set! flin (max 1 (- clin 2))))
  436.              (set! lcol (+ fcol ncol))
  437.          (if (not (and (= oldc fcol) (= oldl flin)))
  438.            (if (and win (= oldc fcol) (< (abs (- oldl flin)) 10))
  439.            (if (< oldl flin)
  440.                (do ((line oldl (1+ line)))
  441.                ((= line flin) (refresh-lines (+ oldl nlin)
  442.                              (+ flin nlin)))
  443.                (window-scroll-up win 0 nlin))
  444.                (do ((line oldl (-1+ line)))
  445.                ((= line flin) (refresh-lines flin 
  446.                              (+ flin (- oldl flin))))
  447.                (window-scroll-down win 0 nlin)))
  448.            (@refresh))
  449.            (disppos))
  450.          (if win (window-set-cursor! win (- clin flin) (- ccol fcol)))
  451.        )))
  452.     
  453.          (with-status (lambda (proc)        ; call proc with popup status window
  454.        (if win
  455.          (begin
  456.            (window-popup status-window)
  457.            (begin0
  458.              (proc status-window)
  459.              (window-popup-delete status-window)))
  460.          (proc #F))))
  461.  
  462.      (displayp (lambda l            ; display items (on status)
  463.        (when (and (pair? l) (pair? (cdr l)) (car (last-pair l)))
  464.          (display (car l) (car (last-pair l)))
  465.          (apply displayp (cdr l)))))
  466.  
  467.      (read-linep (lambda (port)        ; read a line and record entry
  468.        (let ((str (read-line 
  469.             (if (and port
  470.                  (window? input-port)
  471.                  (not (input-string? input-port)))
  472.                 port
  473.                 input-port))))
  474.          (if recd
  475.          (set! keys (string-append keys str (string #\RETURN))))
  476.          str)))
  477.  
  478.      (notify (lambda l            ; write string[s] on status and proceed
  479.        (handle-action
  480.          (with-status
  481.            (lambda (mes)
  482.          (set-cdr! (last-pair l) mes)
  483.          (apply displayp l)
  484.          (read-action))))))
  485.  
  486.          (clear (lambda (name)        ; clear buffer
  487.        (set! buffer (list "" ""))
  488.        (namep name)
  489.        (set! modified #F)
  490.        (set! clin 1)
  491.        (set! flin 1)
  492.        (gc #T)))
  493.  
  494.      (make-blank (lambda (len)
  495.        (make-string len (if (eq? tabulize-mode 'expand)
  496.                 #\space
  497.                 fill))))
  498.  
  499.      (substring-skip (lambda (str pos end)
  500.        (cond ((>= pos end) end)
  501.          ((or (eqv? (string-ref str pos) #\space)
  502.               (eqv? (string-ref str pos) fill))
  503.           (substring-skip str (1+ pos) end))
  504.          (else pos))))
  505.  
  506.          (untabulize (lambda (str)        ; de-tabulize a line when loading
  507.            (let* ((len (string-length str))
  508.                   (pos (substring-find-next-char-in-set str 0 len #\tab)))
  509.              (if (or (null? pos) (= tab 0))
  510.                str
  511.                (string-append
  512.                  (substring str 0 pos)
  513.                  (make-blank (- tab (remainder pos tab)))
  514.                  (untabulize (substring str (1+ pos) len)))))))
  515.  
  516.          (loadp (lambda (name)        ; load a file into editor
  517.        (with-status
  518.          (lambda (mes)
  519.              (displayp "Loading " name mes)
  520.            (let ((fil (open-input-file name)))
  521.                  (do ((cur (list-tail buffer (-1+ clin)) (cdr cur)))
  522.                      ((eof-object? (peek-char fil)) *the-non-printing-object*)
  523.                      (set-cdr! cur (cons (untabulize (read-line fil)) (cdr cur)))
  524.                      (read-char fil))  ; skip LF
  525.                  (close-input-port fil))
  526.                (gc #T)))))
  527.  
  528.          (tabulize (lambda (str)            ; re-tabulize a line for saving
  529.        (let ((len (string-length str)))
  530.          (if (not (eq? tabulize-mode 'normal))
  531.          (do ((idx (-1+ (string-length str)) (-1+ idx))
  532.               (fnd (if (eq? tabulize-mode 'compress) #\space fill))
  533.               (rep (if (eq? tabulize-mode 'expand) #\space fill)))
  534.              ((< idx 0))
  535.              (if (char=? (string-ref str idx) fnd)
  536.              (string-set! str idx rep))))
  537.          ((named-lambda (loop start parts)
  538.         (let* ((pos (substring-find-next-char-in-set str start len fill)))
  539.           (if (not pos)
  540.             (if (null? parts)
  541.             str
  542.             (apply string-append
  543.                    (reverse
  544.                  (if (= start len)
  545.                      (cddr parts)
  546.                      (cons (substring str start len) parts)))))
  547.             (let*
  548.               ((num ((named-lambda (count pos num)
  549.                    (if (and (< pos len)
  550.                     (char=? (string-ref str pos) fill))
  551.                    (count (1+ pos) (1+ num))
  552.                    num))
  553.                  (1+ pos) 1))
  554.                (rul (+ num (remainder pos tab)))
  555.                (adj (if (< rul 8) num rul)))
  556.               (loop
  557.             (+ pos num)
  558.             (list*
  559.               (make-string (remainder adj tab) #\space)
  560.               (make-string (quotient adj tab) #\tab)
  561.               (substring str start pos)
  562.               parts))))))
  563.           0 '()))))
  564.  
  565.          (save (lambda (name)        ; save current file
  566.        (with-status
  567.          (lambda (mes)
  568.            (displayp "Writing " name mes)
  569.            (set! modified #F)
  570.                (if (and bkp (file-exists? name))
  571.                    (let* ((l (reverse (filename-split name)))
  572.                           (ext (if (string-ci=? (car l) ".bak") ".$$$" ".bak"))
  573.                           (new (filename-merge (reverse (cons ext (cdr l))))))
  574.                      (if (file-exists? new) (delete-file new))
  575.                      (dos-rename name new)))
  576.                (let ((fil (open-output-file name)))
  577.                  (do ((curr (cdr buffer) (cdr curr)))
  578.                      ((or (null? curr) 
  579.               (and (null? (cdr curr))
  580.                    (eqv? (car curr) "")))
  581.               *the-non-printing-object*)
  582.                      (display (tabulize (car curr)) fil)
  583.                      (newline fil))
  584.                  (close-output-port fil))
  585.            (gc #T)))))
  586.  
  587.          (displl (lambda ()            ; display last line
  588.        (let* ((clin (+ flin nlin -1))
  589.               (str (list-ref buffer clin)))
  590.          (if (not (null? str)) (write-line win str flin clin fcol lcol)))))
  591.  
  592.          (write-line (lambda (win str flin clin fcol lcol); fit-in and display line
  593.        (when (and win (> (string-length str) fcol))
  594.          (window-set-cursor! win (- clin flin) 0)
  595.              (display
  596.                (substring str fcol (min (string-length str) lcol))
  597.                win))))
  598.  
  599.          (refresh-lines (lambda (start end)
  600.        (let ((start (max start flin))
  601.          (end (max 0 (min nlin (- end flin)))))
  602.          (do ((cur (list-tail buffer start) (cdr cur))
  603.           (n (- start flin) (1+ n)))
  604.          ((>= n end))
  605.          (window-set-attribute! win 'text-attributes attr)
  606.          (window-scroll-up win n (1+ n))
  607.          (if cur (write-line win (car cur) flin (+ flin n) fcol lcol))))
  608.        (disppos)))
  609.  
  610.          (refresh-line (lambda ()            ; refresh current line
  611.        (when win    
  612.          (window-set-attribute! win 'text-attributes attr)
  613.          (window-scroll-up win (- clin flin) (- clin flin -1))
  614.          (write-line win (list-ref buffer clin) flin clin fcol lcol)
  615.          (disppos))))
  616.  
  617.    ; Key processing
  618.  
  619.      (actions action-keys)
  620.      (specials special-keys)
  621.  
  622.      (inkey (lambda (char)
  623.        (when recd 
  624.          (if win (display (integer->char 7)))
  625.          (set! keys (string-append keys (string char))))
  626.        (char->integer char)))
  627.  
  628.          (read-action (lambda ()        ; read and handle a key
  629.        (when win
  630.          (if (and drty (not (char-ready? input-port)))
  631.          (@refresh)
  632.          (window-set-cursor! win (- clin flin) (- ccol fcol))))
  633.        ((named-lambda (decode char)
  634.           (or (cdr (assoc char actions))
  635.           (if (member char specials)
  636.               (if (char-ready? input-port)
  637.               (decode (cons (inkey (read-char input-port)) char))
  638.               (with-status
  639.                 (lambda (mes)
  640.                   (write char mes)
  641.                   (decode (cons (inkey (read-char input-port)) char))))))
  642.           (if (and (integer? char)
  643.                (>= char 32)
  644.                (<= char 255))
  645.               (integer->char char))
  646.           char
  647.           ))
  648.         (inkey (read-char input-port)))))
  649.  
  650.      (handle-action (lambda (action)         ; handle a key-combination
  651.            (cond
  652.          ((char? action)
  653.          (insert-string (string action)))
  654.          ((symbol? action)
  655.              ((dispatch action)))
  656.          ((string? action)
  657.                (do-string action))
  658.          ((proc? action)
  659.              (action me))
  660.          ((and (pair? action) 
  661.            (pair? (car action)))
  662.              (if ((caar action) me)
  663.              (handle-action (cdar action))
  664.              (handle-action (cdr action))))
  665.          (else
  666.              (if win (display (integer->char 7)))))))
  667.  
  668.      (insert-string (lambda (instr)
  669.        (let* ((curr (list-tail buffer clin))
  670.           (len (string-length instr))
  671.           (diff (- (string-length (car curr)) ccol))
  672.           (str (if (>= diff 0)
  673.                (car curr)
  674.                (string-append
  675.                  (car curr)
  676.                  (make-blank (- diff)))))
  677.          )
  678.          (set! modified #T)
  679.          (set-car! curr
  680.                (string-append
  681.              (substring str 0 ccol)
  682.              instr
  683.              (substring str
  684.                     (if insert 
  685.                     ccol
  686.                     (+ ccol (min len (max diff 0))))
  687.                     (+ ccol (max diff 0)))))
  688.          (write-line win (car curr) flin clin fcol lcol)
  689.          (set! ccol (+ ccol len -1))
  690.          (@right))))
  691.  
  692.    ; Interface support
  693.  
  694.          (do-string (lambda (str)        ; feed input port with keys
  695.        (let ((old input-port)
  696.          (asc "")
  697.          (magic-move mmov))
  698.          (set! mmov #f)
  699.          (set! input-port (open-input-string str))
  700.          (do ((doasc (lambda () (when (not (eqv? asc ""))
  701.                       (insert-string asc)
  702.                       (set! asc "")))))
  703.          ((eof-object? (peek-char input-port)) (doasc))
  704.          (let ((action (read-action)))
  705.            (if (char? action)
  706.                (set! asc (string-append asc (string action)))
  707.                (begin (doasc) (handle-action action)))))
  708.          (set! input-port old)
  709.          (set! mmov magic-move)
  710.          (refresh-line)
  711.        )))
  712.  
  713.          (remap-key (lambda (key func)        ; map a function to a key
  714.        (let ((found (assoc key actions)))
  715.          (if found
  716.          (set-cdr! found func)
  717.          (begin
  718.            (set-cdr! actions (cons (cons key func) (cdr actions)))
  719.            (if (pair? key)
  720.                ((named-lambda (scan prefix)
  721.               (when (not (member prefix specials))
  722.                 (set-cdr! prefix (cons prefix (cdr prefix)))
  723.                 (if (pair? prefix) (scan (cdr prefix)))))
  724.             (cdr key))))))))
  725.  
  726.          (position (lambda l            ; set/get cursor/screen position
  727.        (begin0
  728.          (list clin ccol flin fcol)
  729.              (when l
  730.            (set! clin (caar l))
  731.            (set! ccol (cadar l))
  732.            (when (cddar l)
  733.              (set! flin (car (cddar l)))
  734.              (set! fcol (cadr (cddar l))))
  735.            (checkp)))))
  736.  
  737.          (safe (lambda ()            ; ensure modified buffer is saved
  738.        (if modified
  739.          (begin
  740.            (when win (window-popup win) (@refresh))
  741.             (begin0
  742.              (with-status
  743.                (lambda (mes)
  744.              (displayp "File " (namep) " modified. Save (Y/N/Esc) ?" mes)
  745.              ((named-lambda (loop)
  746.                  (case (read-char (or mes input-port))
  747.                   ((#\y #\Y) (@write) #T)
  748.                   ((#\n #\N) #T)
  749.                   (#\escape  #F)
  750.                   (else      (loop)))))))
  751.              (if win (window-popup-delete win))))
  752.          #T)))
  753.  
  754.          (window (lambda w                ; set up the output port
  755.        (begin0
  756.          (cons win (cons nlin ncol))
  757.          (when w
  758.            (set! win (if (window? (car w)) (car w) #F))
  759.                (set! dim (if win (window-get-size win) '(32000 . 32000)))
  760.                (set! nlin (car dim))
  761.                (set! ncol (cdr dim))
  762.                (if (>= (- ccol fcol) ncol) (set! fcol (- ccol ncol -1)))
  763.                (if (>= (- clin flin) nlin) (set! flin (- clin nlin -1)))
  764.                (set! lcol (+ fcol ncol))))))
  765.  
  766.          (status-bg (lambda (status-window name)
  767.        (window-clear status-window)
  768.        (display name status-window)
  769.        (window-set-cursor! status-window 0 50)
  770.        (display "Line: " status-window)
  771.        (window-set-cursor! status-window 0 65)
  772.        (display "Col: " status-window)))
  773.  
  774.          (status-fg (lambda (status-window clin ccol)
  775.        (window-set-cursor! status-window 0 56)
  776.        (display clin status-window)
  777.        (window-set-cursor! status-window 0 70)
  778.        (display (1+ ccol) status-window)))
  779.  
  780.      (namep (lambda l 
  781.        (let ((old (car name)))
  782.          (when l
  783.            (if (and win status-window)
  784.              (begin
  785.            (status-bg status-window (car l))
  786.            (set! name (cons (car l) (window-save-contents status-window)))
  787.            (status-fg status-window clin ccol)
  788.          )
  789.              (set! name (list (car l)))))
  790.          old)))
  791.     
  792.          (disppos (lambda ()
  793.        (when (and win status-window)
  794.          (if (cdr name)
  795.          (window-restore-contents status-window (cdr name))
  796.          (namep (namep)))
  797.          (status-fg status-window clin ccol))))
  798.  
  799.    ; Open an editor, proceed it and hide it
  800.  
  801.          (open (lambda arg
  802.        (if win (window-popup win))
  803.        (when (and (string? (car arg)) (safe))
  804.          (clear (car arg))
  805.          (loadp (car arg)))
  806.            (@refresh)
  807.            (set! todo #F)
  808.            (do () (todo #F) (handle-action (read-action)))
  809.        (if win (window-popup-delete win))
  810.        (case todo
  811.          ('exit *the-non-printing-object*)
  812.          (else  todo))))
  813.  
  814.    ; Message handling
  815.  
  816.          (jobs (append
  817.            (list
  818.          (cons '@up                @up)
  819.          (cons '@left            @left)
  820.          (cons '@right            @right)
  821.          (cons '@down            @down)
  822.          (cons '@page-up            @page-up)
  823.          (cons '@page-down            @page-down)
  824.          (cons '@home            @home)
  825.          (cons '@end            @end)
  826.          (cons '@top-of-buffer        @top-of-buffer)
  827.          (cons '@end-of-buffer        @end-of-buffer)
  828.          (cons '@goto-line            @goto-line)    
  829.          (cons '@backspace            @backspace)
  830.          (cons '@del            @del)
  831.          (cons '@delete-line        @delete-line)  
  832.          (cons '@delete-to-eol        @delete-to-eol)
  833.          (cons '@insert            @insert)    
  834.          (cons '@word-left            @word-left)
  835.          (cons '@word-right            @word-right)
  836.          (cons '@enter            @enter)
  837.          (cons '@tab                         @tab)
  838.          (cons '@quote            @quote)
  839.          (cons '@refresh            @refresh)      
  840.          (cons '@write            @write)     
  841.          (cons '@load            @load)      
  842.          (cons '@read-into            @read-into)    
  843.          (cons '@rename            @rename)      
  844.          (cons '@exit            @exit)      
  845.          (cons '@record            @record)    
  846.          (cons '@play            @play)            
  847.          (cons '@execute            @execute))      
  848.        (list
  849.              (cons 'open open)            ; generic call (automatic)
  850.              (cons 'read-action read-action)    ; read and decode one action
  851.          (cons 'handle-action handle-action); handle one action
  852.          (cons 'do-string do-string)    ; send string to char handler
  853.          (cons 'remap-key remap-key)    ; assign a function to a key
  854.          (cons 'clear clear)            ; clear buffer
  855.              (cons 'refresh-lines refresh-lines); refresh part of screen
  856.              (cons 'refresh-line refresh-line)    ; refresh current line
  857.          (cons 'with-status with-status)    ; handle display in status line
  858.          (cons 'display displayp)        ; display, canceled if editor is off-screen
  859.          (cons 'read-line read-linep)    ; read, from input-port if editor off-screen
  860.          (cons 'notify notify)              ; signal something on status line
  861.              (cons 'load loadp)                ; load file at current line into buffer
  862.              (cons 'save save)                ; write file with buffer
  863.          (cons 'make-blank make-blank)      ; make a "blank" string of given length
  864.          (cons 'substring-skip substring-skip); return pos of the next non-blank char
  865.          (cons 'untabulize untabulize)     ; expand tabs to #\255
  866.          (cons 'tabulize tabulize)         ; squish #\255 to tabs
  867.          (cons 'safe safe)                 ; ensure buffer saved if necessary
  868.          (cons 'position position)         ; set/get all position pointers
  869.          (cons 'window window)             ; use a new/get port for I/O
  870.              (cons 'name namep))        ; get/set the buffer's name
  871.        (list
  872.              (cons 'insert            (lambda l (begin0 insert (if l (set! insert (car l))))))
  873.          (cons 'magic-move            (lambda l (begin0 mmov (if l (set! mmov (car l))))))
  874.              (cons 'tab                    (lambda l (begin0 tab (if l (set! tab (car l))))))
  875.              (cons 'tabulize-mode         (lambda l (begin0 tabulize-mode (if l (set! tabulize-mode (car l))))))
  876.              (cons 'buffer                (lambda l (begin0 buffer (if l (set! buffer (car l))))))
  877.              (cons 'modified              (lambda l (begin0 modified (if l (set! modified (car l))))))
  878.              (cons 'todo                (lambda l (begin0 todo (if l (set! todo (car l))))))
  879.              (cons 'actions               (lambda l (begin0 actions (if l (set! actions (car l))))))
  880.              (cons 'specials              (lambda l (begin0 specials (if l (set! specials (car l))))))
  881.              (cons 'separators            (lambda l (begin0 separators (if l (set! separators (car l))))))
  882.              (cons 'input-port            (lambda l (begin0 input-port (if l (set! input-port (car l))))))
  883.              (cons 'status-window        (lambda l (begin0 status-window (if l (set! status-window (car l))))))
  884.              (cons 'status-fg            (lambda l (begin0 status-fg (if l (set! status-fg (car l))))))
  885.              (cons 'status-bg            (lambda l (begin0 status-bg (if l (set! status-bg (car l))))))
  886.              (cons 'write-line            (lambda l (begin0 write-line (if l (set! write-line (car l))))))
  887.              (cons 'jobs                (lambda l (begin0 jobs (if l (set! jobs (car l))))))
  888.          (cons 'who                    (lambda l (begin0 me (if l (set! me (car l)))))))
  889.      ))
  890.  
  891.          (dispatch (lambda (it)
  892.            (let ((task (assq it jobs)))
  893.          (if task 
  894.              (cdr task)
  895.              (lambda args (%error-invalid-operand 'editor it))))))
  896.  
  897.          (me (lambda args
  898.        (let* ((sta (when (= nest 0)
  899.                  (window input-port)
  900.                  (window-save-contents status-window))))
  901.          (set! nest (1+ nest))
  902.          (if (or (null? args) (string? (car args)))    ; implicit selector
  903.              (set! args (cons 'open args)))
  904.          (begin0 (apply (dispatch (car args)) (cdr args))
  905.              (set! nest (-1+ nest))
  906.              (if (= nest 0)
  907.                  (window-restore-contents status-window sta))))
  908.        ))
  909.  
  910.     )   ; LETREC bindings
  911.  
  912.     (if (not (memq 'EXIT-FREELY param))
  913.         (editor-handle-exit 'remember me))
  914.     (if (window? input-port) 
  915.         (set! attr (window-get-attribute input-port 'text-attributes)))
  916.     me
  917.                   
  918.       )   ; LETREC
  919.     )    ; LAMBDA param
  920.   )   ; SET! make-editor
  921. )   ; LET
  922.  
  923.  
  924. ;**************************************************************************
  925. ; This is how to derive an enhanced editor from the previous one...
  926.  
  927.  
  928. (let*                    ; values shared by all editors
  929.   ((scrap '(line))            ; scrapboard (block-type . (text))
  930.  
  931.    (block? (lambda (ed)            ; context discriminator
  932.          (car (ed 'select))))
  933.  
  934.    (special-keys
  935.      (cons '(36 . 0) ((make-editor 'EXIT-FREELY) 'specials)))
  936.  
  937.    (action-keys
  938.      (append
  939.        (list
  940.      (cons (list* 050 000) '@mark-block)    ; Alt-M: Mark region
  941.      (cons (list* 038 000) '@line-block)     ; Alt-L: Line region
  942.      (cons (list* 046 000) '@column-block)  ; Alt-C: Column region
  943.      (cons (list* 082 000) '@insert-block)  ; Ins: Paste block
  944.      (cons (list* 083 000) (list* (cons block? '@delete-block)
  945.                       '@del))   ; Del: Delete char or block
  946.      (cons (list*     043) (list* (cons block? '@copy-block)
  947.                       #\+))     ; '+': Copy blcok
  948.      (cons (list*     045) (list* (cons block? '@cut-block)
  949.                       #\-))     ; '-': Cut blcok
  950.      (cons (list*     047) (list* (cons block? '@swap-anchor)
  951.                       #\/))     ; '/': Swap mark & cursor
  952.      (cons (list* 017 000) (list* (cons block? '@write-block)
  953.                       '@write))    ; Alt-W: Write file or block
  954.      (cons (list*     018) '@replicate)    ; Ctrl-R
  955.      (cons (list* 031 000) '@search)    ; Alt-S
  956.      (cons (list* 020 000) '@translate)    ; Alt-T
  957.      (cons (list* 063 000) '@search)    ; F5
  958.      (cons (list* 088 000) '@repeat-search)    ; Shift-F5
  959.      (cons (list* 064 000) '@translate)    ; F6
  960.      (cons (list* 089 000) '@repeat-translate); Shift-F6
  961.      (cons (list* 098 000) '@case-sensitivity); Ctrl-F5
  962.      (cons (list* 120 000) '@bookmark-1)    ; Alt-[1-3]
  963.      (cons (list* 121 000) '@bookmark-2)
  964.      (cons (list* 122 000) '@bookmark-3)
  965.      (cons (list* 49 36 0) '@jump-to-1)    ; Alt-J [1-3]
  966.      (cons (list* 50 36 0) '@jump-to-2)
  967.      (cons (list* 51 36 0) '@jump-to-3)
  968.        )
  969.        ((make-editor 'EXIT-FREELY) 'actions)))
  970.   )
  971.  
  972.   (set! make-enhanced-editor
  973.     (lambda param
  974.       (letrec
  975.         (
  976.          (ed (apply make-editor param))
  977.  
  978.          (btyp #f)                ; block type: {#f 'line 'char 'col}
  979.          (blin 1)                        ; start of block
  980.          (bcol 0)
  981.          (mtyp #f)                ; magic-move-mode to restore
  982.          (epos '())
  983.          (win #F)
  984.          (clin 1)
  985.          (ccol 0)
  986.          (flin 1)
  987.          (fcol 0)
  988.          (mmov #f)
  989.      (top 1)
  990.      (bot 1)
  991.      (bookmarks (make-vector 10 '(1 0 1 0)))
  992.      (case-sensitivity #t)            ; default to case-sensitive
  993.      (search-objects (list "" "" ""))
  994.  
  995.    ; Key handling support           
  996.            
  997.          (get-values (lambda ()
  998.        (set! mmov (ed 'magic-move))
  999.        (set! epos (ed 'position))
  1000.        (set! clin (car epos))
  1001.        (set! ccol (cadr epos))
  1002.        (set! flin (caddr epos))
  1003.        (set! fcol (cadddr epos))
  1004.        (set! top (min blin clin))
  1005.        (set! bot (max blin clin))
  1006.          ))
  1007.  
  1008.      (refresh (lambda (newlin)
  1009.            (if (= flin (caddr (ed 'position (list newlin ccol))))
  1010.            (ed 'refresh-lines (min clin newlin)
  1011.            (if (eq? (car scrap) 'col)
  1012.                (1+ (max clin newlin))
  1013.                (length (ed 'buffer)))))))
  1014.  
  1015.    ; Key handling
  1016.  
  1017.          (@mark (lambda (type)
  1018.              (lambda ()
  1019.        (if (eq? btyp type)
  1020.            (@cancel-block)
  1021.            (begin 
  1022.          (get-values)
  1023.          (when (not btyp)
  1024.            (if mmov (ed 'magic-move 'hard))
  1025.            (set! mtyp mmov)
  1026.            (set! bcol ccol)
  1027.            (set! blin clin))
  1028.          (set! btyp type)
  1029.          (get-values)
  1030.          (if mmov (ed 'refresh-lines top (1+ bot))))))))
  1031.  
  1032.      (@cancel-block (lambda ()
  1033.        (when btyp
  1034.          (get-values)
  1035.          (if mtyp (ed 'magic-move mtyp))
  1036.          (set! btyp #f)
  1037.          (if mmov (ed 'refresh-lines top (1+ bot))))))
  1038.  
  1039.      (@insert-block (lambda ()
  1040.        (get-values)
  1041.        (let* ((ante (list-tail (ed 'buffer) (-1+ clin)))
  1042.           (str (cadr ante))
  1043.           (len (string-length str))
  1044.           (putline (named-lambda (putline scrap)
  1045.                  (when scrap
  1046.                    (set-cdr! ante (cons (car scrap) (cdr ante)))
  1047.                    (putline (cdr scrap)))))
  1048.          )
  1049.          (case (car scrap)
  1050.            ('line (putline (cdr scrap)))
  1051.            ('char (let ((fstr (substring str 0 ccol)))
  1052.             (set-car! (cdr ante) (string-append
  1053.                            (cadr scrap)
  1054.                            (substring str ccol len)))
  1055.             (putline (cddr scrap))
  1056.             (set-car! (cdr ante) (string-append fstr (cadr ante)))
  1057.             (set! ccol (+ (string-length (cadr scrap))
  1058.                       (if (null? (cddr scrap)) ccol 0)))
  1059.               ))
  1060.            ('col ((named-lambda (putline scrap ante)
  1061.             (when scrap
  1062.               (cond
  1063.                 ((null? (cdr ante))
  1064.                   (set-cdr! ante 
  1065.                     (list (string-append
  1066.                         (ed 'make-blank ccol)
  1067.                         (car scrap)))))
  1068.                 ((<= (string-length (cadr ante)) ccol)
  1069.                   (set-car! (cdr ante)
  1070.                     (string-append
  1071.                       (cadr ante)
  1072.                       (ed 'make-blank (- ccol (string-length (cadr ante))))
  1073.                       (car scrap))))
  1074.                 (else
  1075.                   (set-car! (cdr ante)
  1076.                     (string-append
  1077.                       (substring (cadr ante) 0 ccol)
  1078.                       (car scrap)
  1079.                       (substring (cadr ante) ccol 
  1080.                              (string-length (cadr ante)))))))
  1081.               (putline (cdr scrap) (cdr ante))
  1082.             ))
  1083.               (reverse (cdr scrap)) ante)
  1084.              (set! ccol (+ ccol (string-length (cadr scrap)))))
  1085.          ))
  1086.         (refresh (+ clin (length scrap) 
  1087.             (if (eq? (car scrap) 'col) -1 -2)))
  1088.      ))
  1089.  
  1090.      (@delete-block (lambda ()
  1091.        (let ((old scrap))
  1092.          (@cut-block)
  1093.          (set! scrap old))
  1094.        (ed 'notify "Block deleted")
  1095.          ))
  1096.  
  1097.      (@copy-block (lambda ()
  1098.        (get-values)
  1099.        (when (not btyp)
  1100.          (set! btyp 'line)
  1101.          (set! blin clin))
  1102.        (set! scrap '())
  1103.        (do ((curr (list-tail (ed 'buffer) top) (cdr curr))
  1104.            (n top (1+ n))
  1105.         (width (1+ (abs (- bcol ccol)))))
  1106.            ((> n bot))
  1107.            (let* ((str (car curr))
  1108.               (len (string-length str))
  1109.               (sran (srange n 0 len))
  1110.               (spac (- width (- (cdr sran) (car sran)))))
  1111.          (set! scrap 
  1112.            (cons (if (eq? btyp 'col)
  1113.                  (string-append
  1114.                    (substring str (car sran) (cdr sran))
  1115.                    (ed 'make-blank spac))
  1116.                  (substring str (car sran) (cdr sran)))
  1117.              scrap))))
  1118.        (set! scrap (cons btyp scrap))
  1119.        (@cancel-block)
  1120.        (ed 'notify "Block copied to scrap")
  1121.      ))
  1122.  
  1123.      (@cut-block (lambda ()
  1124.        (get-values)
  1125.        (when (not btyp)
  1126.          (set! btyp 'line)
  1127.          (set! blin clin))
  1128.        (set! scrap '())
  1129.        (let* ((ante (list-tail (ed 'buffer) (-1+ top)))
  1130.           (last (list-tail ante (1+ (- bot top)))))
  1131.          (case btyp
  1132.            ('line (set! scrap (cdr ante))
  1133.               (set-cdr! ante (cdr last))
  1134.               (set-cdr! last '())
  1135.               (set! scrap (reverse! scrap)))
  1136.            ('char (let* ((flen (string-length (cadr ante)))
  1137.                  (fran (srange top 0 flen))
  1138.                  (fstr (substring (cadr ante) (car fran) (cdr fran)))
  1139.                  (llen (string-length (car last)))
  1140.                  (lran (srange bot 0 llen))
  1141.                 )
  1142.             (set-car! (cdr ante)
  1143.                   (string-append
  1144.                     (substring (cadr ante) 0 (car fran))
  1145.                     (substring (car last) (cdr lran) llen)))
  1146.             (when (<> top bot) 
  1147.               (set! scrap (cddr ante))
  1148.               (set-cdr! (cdr ante) (cdr last))
  1149.               (set-car! last (substring (car last) 0 (cdr lran)))
  1150.               (set-cdr! last '()))
  1151.             (set! scrap (reverse! (cons fstr scrap)))))
  1152.            ('col (do ((curr (cdr ante) (cdr curr))
  1153.               (line top (1+ line))
  1154.               (width (1+ (abs (- bcol ccol)))))
  1155.              ((> line bot))
  1156.              (let* ((len (string-length (car curr)))
  1157.                 (sran (srange line 0 len))
  1158.                 (spac (- width (- (cdr sran) (car sran)))))
  1159.                (set! scrap 
  1160.                  (cons (string-append
  1161.                      (substring (car curr) (car sran) (cdr sran))
  1162.                      (ed 'make-blank spac))
  1163.                    scrap))
  1164.                (set-car! curr
  1165.                      (string-append
  1166.                        (substring (car curr) 0 (car sran))
  1167.                        (substring (car curr) (cdr sran) len))))))
  1168.          ))
  1169.        (if mtyp (ed 'magic-move mtyp))
  1170.        (set! scrap (cons btyp scrap))
  1171.        (set! btyp #f)
  1172.        (set! ccol (if (= clin top) (min ccol bcol) bcol))
  1173.        (set! clin bot)
  1174.        (refresh top)
  1175.        (ed 'notify "Block deleted to scrap")
  1176.      ))
  1177.  
  1178.          (@write-block (lambda ()
  1179.        (when btyp
  1180.          (ed 'with-status
  1181.          (lambda (mes)
  1182.            (ed 'display "Write block as: " mes)
  1183.            (let ((name (ed 'read-line mes)))
  1184.              (when 
  1185.                (or (not mes) 
  1186.                (not (file-exists? name))
  1187.                (begin
  1188.                  (window-clear mes)
  1189.                  (display "Overwrite existing file (Y/N) ? " mes)
  1190.                  ((named-lambda (loop)
  1191.                 (case (read-char mes)
  1192.                   ((#\y #\Y) #T)
  1193.                   ((#\n #\N) #F)
  1194.                   (else      (loop)))))))
  1195.                (write-block name))))))))
  1196.  
  1197.      (@swap-anchor (lambda ()
  1198.        (when btyp
  1199.          (get-values)
  1200.          (set! epos (list blin bcol))
  1201.          (set! blin    clin)
  1202.          (set! bcol ccol)
  1203.          (ed 'position epos)
  1204.        )))
  1205.  
  1206.      (@replicate (lambda ()
  1207.        (let* ((input-port (ed 'input-port))
  1208.           (action '())
  1209.           (count
  1210.            (string->number 
  1211.              (ed 'with-status (lambda (mes)
  1212.                (ed 'display "Enter count, then press the key to replicate: " mes)
  1213.                ((named-lambda (loop)
  1214.               (let ((key (ed 'read-action)))
  1215.                 (if (and (char? key)
  1216.                      (char>=? key #\0)
  1217.                      (char<=? key #\9))
  1218.                 (begin
  1219.                   (ed 'display key mes)
  1220.                   (string-append (string key) (loop)))
  1221.                 (begin
  1222.                   (set! action key)
  1223.                   "")))))
  1224.              ))))
  1225.          )
  1226.          (if (char? action)
  1227.          (ed 'do-string (make-string count action))
  1228.          (do ((magic-move (ed 'magic-move #f))
  1229.               (idx count (-1+ idx)))
  1230.              ((<= idx 0)(ed 'magic-move magic-move))
  1231.              (ed 'handle-action action)))
  1232.          (ed 'refresh-line)
  1233.        )))
  1234.  
  1235.      (@bookmark (lambda (n)
  1236.               (lambda ()
  1237.        (let ((pos (ed 'position)))
  1238.          (set-cdr! (cdr pos) '())
  1239.          (vector-set! bookmarks n pos))
  1240.        (ed 'notify "Bookmark " n " dropped")
  1241.      )))
  1242.  
  1243.      (@jump-to (lambda (n)
  1244.               (lambda ()
  1245.        (ed 'position (vector-ref bookmarks n)))))
  1246.  
  1247.      (@case-sensitivity (lambda ()
  1248.        (set! case-sensitivity (not case-sensitivity))
  1249.        (ed 'notify "Case sensitivity "
  1250.            (if case-sensitivity "on" "off"))))
  1251.  
  1252.      (@search (lambda ()
  1253.        (set-car! search-objects
  1254.          (ed 'with-status
  1255.          (lambda (mes)
  1256.            (ed 'display "Search for: " mes)
  1257.            (ed 'read-line mes))))
  1258.        (@repeat-search)))
  1259.  
  1260.      (@repeat-search (lambda ()
  1261.        (get-values)
  1262.        (let ((res (search clin (1+ ccol) (car search-objects))))
  1263.          (if res
  1264.          (ed 'position res) 
  1265.          (ed 'notify "Target not found")))))
  1266.  
  1267.      (@translate (lambda ()
  1268.        (set-car! (cdr search-objects)
  1269.          (ed 'with-status
  1270.          (lambda (mes)
  1271.            (ed 'display "Translate what: " mes)
  1272.            (ed 'read-line mes))))
  1273.        (set-car! (cddr search-objects)
  1274.          (ed 'with-status
  1275.          (lambda (mes)
  1276.            (ed 'display "Replace with: " mes)
  1277.            (ed 'read-line mes))))
  1278.        (@repeat-translate)))
  1279.  
  1280.      (@repeat-translate (lambda ()
  1281.        (get-values)
  1282.        ((named-lambda (next line col global?)
  1283.           (let*
  1284.         ((res (search line col (cadr search-objects)))
  1285.          (curr (list-tail (ed 'buffer) (car res)))
  1286.          (todo
  1287.            (if global? 
  1288.              (if res '(#t #t) '(#f))
  1289.              (if res
  1290.                (begin
  1291.              (ed 'position res)
  1292.              (ed 'with-status
  1293.                (lambda (mes)
  1294.                  (ed 'display "Change ? (Yes No Global One Finished Abort)" mes)
  1295.                  ((named-lambda (loop)
  1296.                 (case (ed 'read-action)
  1297.                   ((#\y #\Y) '(#t #f))
  1298.                   ((#\n #\N) '(#f #f))
  1299.                   ((#\g #\G) '(#t #t))
  1300.                   ((#\o #\O) '(#t))
  1301.                   ((#\f #\F) '(#f))
  1302.                   ((#\a #\A) (set! clin (car res))
  1303.                              (set! ccol (cadr res))
  1304.                          '(#f))
  1305.                   (else     (loop))))))))
  1306.                (begin 
  1307.              (ed 'notify "Target not found") 
  1308.              '(#f))))))
  1309.         (when (car todo)        ; Replace ?
  1310.           (set-car! curr
  1311.             (string-append
  1312.               (substring (car curr) 0 (cadr res))
  1313.               (caddr search-objects)
  1314.               (substring (car curr) 
  1315.                  (+ (cadr res) 
  1316.                     (string-length (cadr search-objects)))
  1317.                  (string-length (car curr)))))
  1318.           (if (not global?) (ed 'refresh-line)))
  1319.         (if (cdr todo)            ; Repeat ?
  1320.             (next (car res) (1+ (cadr res)) (cadr todo))
  1321.             (if global? (ed '@refresh)))))
  1322.         clin ccol #f)
  1323.        (ed 'position (list clin ccol))))
  1324.  
  1325.    ; Interface support
  1326.  
  1327.          (write-block (lambda (name)
  1328.        (when btyp
  1329.          (get-values)
  1330.          (do ((fil (open-output-file name))
  1331.           (curr (list-tail (ed 'buffer) top) (cdr curr))
  1332.           (n top (1+ n)))
  1333.          ((> n bot) (close-output-port fil))
  1334.          (let* ((str (car curr))
  1335.             (len (string-length str))
  1336.             (sran (srange n 0 len)))
  1337.            (display (ed 'tabulize (substring str (car sran) (cdr sran))) fil)
  1338.            (newline fil)))
  1339.          (gc #T))))
  1340.  
  1341.          (srange (lambda (line fcol lcol)
  1342.        (when btyp
  1343.          (get-values)
  1344.          (let ((blft (min lcol (max fcol bcol)))
  1345.            (brgt (min lcol (max fcol (1+ bcol))))
  1346.            (clft (min lcol (max fcol ccol)))
  1347.            (crgt (min lcol (max fcol (1+ ccol)))))
  1348.            (cond
  1349.              ((or (> line bot) 
  1350.               (< line top)) #f)
  1351.              ((eq? btyp 'line) (cons fcol lcol))
  1352.              ((or (eq? btyp 'col)
  1353.               (and (= top bot) (= top line)))
  1354.               (cons (min blft clft) (max brgt crgt)))
  1355.              ((= line top) (cons (if (= top blin) blft clft) lcol))
  1356.              ((= line bot) (cons fcol (if (= top blin) crgt brgt)))
  1357.              (else (cons fcol lcol)))))
  1358.        ))
  1359.  
  1360.          (select (lambda l
  1361.        (begin0
  1362.          (list btyp blin bcol)
  1363.          (when l
  1364.            (when (not btyp) 
  1365.              (set! mtyp (ed 'magic-move))
  1366.              (if mtyp (ed 'magic-move 'hard)))
  1367.            (set! btyp (caar l))
  1368.            (if btyp
  1369.            (begin (set! blin (cadar l))
  1370.                   (set! bcol (caddar l)))
  1371.            (if mtyp (ed 'magic-move mtyp)))))))
  1372.  
  1373.      (search (lambda (clin ccol match)
  1374.        (let* ((find (if case-sensitivity
  1375.                 substring-find-next-string
  1376.                 substring-find-next-string-ci))
  1377.           (curr (list-tail (ed 'buffer) clin))
  1378.           (len (string-length (car curr))))
  1379.          (do ((line clin (1+ line))
  1380.           (pos (find (car curr) (min len ccol) len match)
  1381.                (find (car curr) 0 (string-length (car curr)) match)))
  1382.          ((or (null? (cdr curr)) pos) (if pos (list line pos)))
  1383.          (set! curr (cdr curr))))
  1384.      ))
  1385.  
  1386.      (click (lambda (left center right x y)
  1387.        (get-values)
  1388.        (cond 
  1389.          ((> left 0)  (ed 'position (list (+ flin (quotient y 8)) 
  1390.                           (+ fcol (quotient x 8)))))
  1391.          ((> right 0) (select '(#f))))
  1392.      ))
  1393.  
  1394.      (mouse-block '(((LEFT)        . CHAR)
  1395.             ((RIGHT)    . LINE)
  1396.             ((CENTER)    . COL)
  1397.             ((LEFT RIGHT)    . COL)))
  1398.  
  1399.      (drag-start (lambda (buttons x y)
  1400.        (get-values)
  1401.        (select (list (cdr (assoc buttons mouse-block))
  1402.              (+ flin (quotient y 8)) 
  1403.              (+ fcol (quotient x 8))))))
  1404.  
  1405.      (drag (lambda (x y)
  1406.        (when (not (desktop 'pending?))
  1407.          (get-values)
  1408.          (let ((line (quotient y 8))
  1409.            (col (quotient x 8)))
  1410.            (ed 'position (list (+ flin line) (+ fcol col)))
  1411.            (ed 'refresh-lines (min (+ flin line) clin)
  1412.                           (1+ (max (+ flin line) clin)))))))
  1413.  
  1414.    ; Message handling
  1415.  
  1416.          (jobs (append
  1417.        (list
  1418.          (cons '@mark-block        (@mark 'char))
  1419.          (cons '@line-block        (@mark 'line)) 
  1420.          (cons '@column-block    (@mark 'col))
  1421.          (cons '@cancel-block    @cancel-block)
  1422.          (cons '@copy-block        @copy-block)
  1423.          (cons '@cut-block        @cut-block)
  1424.          (cons '@delete-block    @delete-block)
  1425.          (cons '@insert-block    @insert-block)
  1426.          (cons '@write-block    @write-block)
  1427.          (cons '@swap-anchor        @swap-anchor)
  1428.          (cons '@replicate        @replicate)
  1429.          (cons '@bookmark-1        (@bookmark 1))
  1430.          (cons '@bookmark-2        (@bookmark 2))
  1431.          (cons '@bookmark-3        (@bookmark 3))
  1432.          (cons '@jump-to-1          (@jump-to 1))
  1433.          (cons '@jump-to-2          (@jump-to 2))
  1434.          (cons '@jump-to-3          (@jump-to 3))
  1435.          (cons '@case-sensitivity   @case-sensitivity)
  1436.          (cons '@search        @search)
  1437.          (cons '@repeat-search      @repeat-search)
  1438.          (cons '@translate          @translate)
  1439.          (cons '@repeat-translate   @repeat-translate)
  1440.          (cons 'scrap         (lambda l (begin0 scrap (if l (set! scrap (car l))))))
  1441.          (cons 'bookmarks         (lambda l (begin0 bookmarks (if l (set! bookmarks (car l))))))
  1442.          (cons 'case-sensitivity    (lambda l (begin0 case-sensitivity (if l (set! case-sensitivity (car l))))))
  1443.          (cons 'search-objects     (lambda l (begin0 search-objects (if l (set! search-objects (car l))))))
  1444.          (cons 'search              search)
  1445.              (cons 'selection-range        srange)
  1446.          (cons 'select        select)
  1447.          (cons 'write-block         write-block)
  1448.          (cons 'click               click)
  1449.          (cons 'drag-start          drag-start)
  1450.          (cons 'drag-move        drag)
  1451.          (cons 'drag-end            drag)
  1452.          )
  1453.        (ed 'jobs)))
  1454.  
  1455.         ) ; LETREC bindings
  1456.  
  1457.     (ed 'actions    action-keys)        ; initialization
  1458.     (ed 'specials    special-keys)
  1459.     (ed 'jobs       jobs)
  1460.     ed
  1461.  
  1462.       )   ; LETREC
  1463.     )    ; LAMBDA param
  1464.   )   ; SET! make-editor
  1465. )   ; LET
  1466.  
  1467.  
  1468. ;**************************************************************************
  1469. ; Now customize the enhenced-editor do get a color editor...
  1470.  
  1471.  
  1472. (define (make-color-editor . param)
  1473.   (letrec
  1474.     (
  1475.       (ed (apply make-enhanced-editor param))
  1476.       (win (ed 'window))
  1477.       (colors '((00 . #x07) (50 . #x0f) (100 . #x17) (150 . #x1f)
  1478.         (01 . #x0e) (51 . #x0f) (101 . #x1e) (151 . #x1f)
  1479.         (02 . #x0a) (52 . #x0f) (102 . #x1a) (152 . #x1f)
  1480.         (03 . #x0b) (53 . #x0f) (103 . #x1b) (153 . #x1f)
  1481.         (04 . #x0e) (54 . #x0f) (104 . #x1e) (154 . #x1f)
  1482.         (05 . #x0a) (55 . #x0f) (105 . #x1a) (155 . #x1f)
  1483.         (06 . #x0b) (56 . #x0f) (106 . #x1b) (156 . #x1f)
  1484.         (07 . #x0e) (57 . #x0f) (107 . #x1e) (157 . #x1f)
  1485.         (08 . #x0a) (58 . #x0f) (108 . #x1a) (158 . #x1f)
  1486.         (09 . #x0b) (59 . #x0f) (109 . #x1b) (159 . #x1f)
  1487.         (10 . #x0e) (60 . #x0f) (110 . #x1e) (160 . #x1f)
  1488.         (11 . #x0a) (61 . #x0f) (111 . #x1a) (161 . #x1f)
  1489.         (12 . #x0b) (62 . #x0f) (112 . #x1b) (162 . #x1f)
  1490.         (13 . #x0e) (63 . #x0f) (113 . #x1e) (163 . #x1f)
  1491.         (14 . #x0a) (64 . #x0f) (114 . #x1a) (164 . #x1f)
  1492.         (15 . #x0b) (65 . #x0f) (115 . #x1b) (165 . #x1f)
  1493.         (16 . #x0e) (66 . #x0f) (116 . #x1e) (166 . #x1f)
  1494.         (17 . #x0a) (67 . #x0f) (117 . #x1a) (167 . #x1f)
  1495.         (18 . #x0b) (58 . #x0f) (118 . #x1b) (158 . #x1f)
  1496.         (19 . #x0e) (69 . #x0f) (119 . #x1e) (169 . #x1f)
  1497.         (20 . #x0a) (70 . #x0f) (120 . #x1a) (170 . #x1f)
  1498.         (21 . #x0b) (71 . #x0f) (121 . #x1b) (171 . #x1f)
  1499.         (22 . #x0e) (72 . #x0f) (122 . #x1e) (172 . #x1f)
  1500.         (23 . #x0a) (73 . #x0f) (123 . #x1a) (173 . #x1f)
  1501.         (24 . #x0b) (74 . #x0f) (124 . #x1b) (174 . #x1f)
  1502.         (25 . #x0e) (75 . #x0f) (125 . #x1e) (175 . #x1f)
  1503.         (26 . #x0a) (76 . #x0f) (126 . #x1a) (176 . #x1f)
  1504.         (27 . #x0b) (77 . #x0f) (127 . #x1b) (177 . #x1f)
  1505.         (28 . #x0e) (78 . #x0f) (128 . #x1e) (178 . #x1f)
  1506.         (29 . #x0a) (79 . #x0f) (129 . #x1a) (179 . #x1f)
  1507.         (30 . #x0b) (80 . #x0f) (130 . #x1b) (180 . #x1f)
  1508.         (31 . #x0e) (81 . #x0f) (131 . #x1e) (181 . #x1f)
  1509.         (32 . #x0a) (82 . #x0f) (132 . #x1a) (182 . #x1f)
  1510.         ))                 
  1511.                          
  1512. ; Interface support
  1513.  
  1514.       (deepize (lambda (str clin)
  1515.     '((0 . (0 . 0)))))
  1516.  
  1517.       (memo '())                ; buffer for MRU detailed line deepness
  1518.       (upper-depth (list 0))            ; global deepness of first lines
  1519.       (upper-floor (list 0))            ; minimum deepness of first lines
  1520.  
  1521.       (ensure (lambda (clin)        ; ensure upper- values are known until clin
  1522.     (let* ((plin (length upper-depth))
  1523.            (extend (named-lambda (extend curr depth flor plin)
  1524.          (if (= plin clin)
  1525.              (begin (set! upper-depth depth)
  1526.                 (set! upper-floor flor))
  1527.              (let ((info (cdar (str-colors (car curr) plin))))
  1528.                (extend (cdr curr)
  1529.                    (cons (+ (car depth) (car info)) depth)
  1530.                    (cons (+ (car depth) (cdr info)) flor)
  1531.                    (1+ plin))))))
  1532.            (doit (lambda ()
  1533.          (extend (list-tail (ed 'buffer) plin) 
  1534.              upper-depth upper-floor plin))))
  1535.            
  1536.       (if (< plin clin)
  1537.         (if (> (- clin plin) 40)
  1538.         (ed 'with-status 
  1539.             (lambda (mes)
  1540.               (ed 'display "Please wait..." mes)
  1541.               (doit)))
  1542.         (doit))))))
  1543.  
  1544.       (line-depth (lambda (clin)
  1545.     (ensure clin)
  1546.     (list-ref upper-depth (- (length upper-depth) clin))))
  1547.  
  1548.       (line-floor (lambda (clin)
  1549.     (ensure clin)
  1550.     (list-ref upper-floor (- (length upper-floor) clin))))
  1551.  
  1552.       (valid-line (lambda (clin deep)    ; valid upper- knowledge with new data
  1553.     (let* ((base (line-depth clin))
  1554.            (next (line-depth (1+ clin)))
  1555.            (flor (line-floor (1+ clin)))
  1556.            (plin (length upper-depth)))
  1557.       (when (or (<> (- next base) (cadar deep))
  1558.             (<> (- flor base) (cddar deep)))
  1559.         (set! upper-depth (list-tail upper-depth (- plin clin)))
  1560.         (set! upper-floor (list-tail upper-floor (- plin clin))))
  1561.       base)))
  1562.  
  1563.       (str-colors (lambda (str clin)    ; quickly find colors of str
  1564.     (let* ((deep (assq str memo))
  1565.            (buffer (ed 'buffer))
  1566.  
  1567.            (clean (named-lambda (clean memo prev scan size)
  1568.          (cond ((null? scan) memo)
  1569.                ((= size 0) (set-cdr! scan '()))
  1570.                (else (if (not (memq (car scan) buffer))
  1571.                  (set-cdr! prev (cdr scan)))
  1572.                  (clean memo (cdr prev) (cdr scan) (-1+ size)))))))
  1573.  
  1574.       (when (not deep)
  1575.         (set! deep (cons str (deepize str clin)))
  1576.         (set! memo (cons deep memo))
  1577.         (if (> (length memo) 100) (clean memo memo (cdr memo) 50)))
  1578.       (cdr deep))
  1579.     ))
  1580.  
  1581.       (write-line (lambda (win strg flin clin fcol lcol) ; fit-in and display a line
  1582.     (let* ((sran (ed 'selection-range clin fcol lcol))
  1583.            (diff (if sran (- (cdr sran) (string-length strg)) 0))
  1584.            (str  (if (> diff 0) 
  1585.              (string-append strg (make-string diff #\space))
  1586.              strg))
  1587.            (len  (min (string-length str) lcol))
  1588.  
  1589.            (skip (named-lambda (skip deep)
  1590.          (if (or (null? (cdr deep)) (> (cdadr deep) fcol))
  1591.              deep
  1592.              (skip (cdr deep)))))
  1593.  
  1594.            (disp (named-lambda (disp from deep base len)
  1595.          (window-set-attribute! win 'text-attributes 
  1596.                     (cdr (or (assq (+ base (caar deep)) colors)
  1597.                          (assq 0 colors))))
  1598.          (if (or (null? (cdr deep)) (> (cdadr deep) len))
  1599.              (begin (display (substring str from len) win)
  1600.                 deep)
  1601.              (begin (display (substring str from (cdadr deep)) win)
  1602.                 (disp (cdadr deep) (cdr deep) base len)))))
  1603.  
  1604.            (scol (str-colors str clin))
  1605.            (base (valid-line clin scol))
  1606.            (deep (skip scol)))
  1607.  
  1608.       (when (and win (or sran (> (string-length strg) fcol)))
  1609.         (window-set-cursor! win (- clin flin) 0)
  1610.         (if sran
  1611.         (disp (cdr sran)
  1612.               (disp (car sran)
  1613.                 (disp fcol deep base (car sran))
  1614.                 (+ base 100) (cdr sran))
  1615.               base len)
  1616.         (disp fcol deep base len))))
  1617.         ))
  1618.  
  1619.       (line-colors (lambda (clin)
  1620.     (str-colors (list-ref (ed 'buffer) clin) clin)))
  1621.  
  1622.       (with-cursor (lambda (proc)    ; generic list search by cursor pos
  1623.              (lambda (clin ccol)
  1624.     (letrec ((str  (list-ref (ed 'buffer) clin))
  1625.          (deep (str-colors str clin))
  1626.          (scan (lambda (curr ccol)
  1627.              (if (or (null? (cdr curr)) (> (cdadr curr) ccol))
  1628.                  (proc deep curr str clin ccol)
  1629.                  (scan (cdr curr) ccol)))))
  1630.       (scan deep ccol)))))
  1631.  
  1632.       (cursor-color (with-cursor
  1633.     (lambda (deep curr str clin ccol)
  1634.       (+ (list-ref upper-depth (- (length upper-depth) clin))
  1635.          (caar curr)))))
  1636.  
  1637.       (left-colors (with-cursor
  1638.     (lambda (deep curr str clin ccol)
  1639.       (let ((deep (copy deep)))
  1640.         (set-cdr! (car deep) 0)
  1641.         (list-tail (reverse! (if (> (caar deep) 0)
  1642.                      (cons (cons 0 0) deep)
  1643.                      deep))
  1644.                (-1+ (length curr)))))))
  1645.  
  1646.       (right-colors (with-cursor
  1647.     (lambda (deep curr str clin ccol)
  1648.       (reverse! (cons (cons (cadar deep) (string-length str))
  1649.               (reverse (cdr curr)))))))
  1650.  
  1651. ; Message handling
  1652.  
  1653.       (jobs (append
  1654.     (list
  1655.           (cons 'colors               (lambda l (begin0 colors (if l (set! colors (car l))))))
  1656.           (cons 'deepize           (lambda l (begin0 deepize (if l (set! deepize (car l))))))
  1657.       (cons 'upper-depth           (lambda l (begin0 upper-depth (if l (set! upper-depth (car l))))))
  1658.       (cons 'upper-floor           (lambda l (begin0 upper-floor (if l (set! upper-floor (car l))))))
  1659.       (cons 'line-depth line-depth)    ; get initial depth of a line
  1660.       (cons 'line-floor line-floor)    ; get minimum depth of precedent line
  1661.       (cons 'valid-line valid-line)    ; valid upper- data with new line
  1662.       (cons 'line-colors line-colors)  ; get colors of a line
  1663.       (cons 'left-colors left-colors)  ; idem, left of cursor, nearest first
  1664.       (cons 'right-colors right-colors); idem, right of cursor, nearest first
  1665.       (cons 'cursor-color cursor-color); get color of current position
  1666.       )
  1667.     (ed 'jobs)))
  1668.  
  1669.     ) ; LETREC bindings
  1670.  
  1671.   (ed 'jobs       jobs)              ; initialization
  1672.   (ed 'write-line write-line)
  1673.   (ed 'magic-move 'soft)
  1674.   ed)
  1675. )     ; DEFINE
  1676.  
  1677.  
  1678. ;**************************************************************************
  1679. ; Let's see how to customize a color-editor to make a scheme-editor...
  1680.  
  1681.  
  1682. (let*                    ; values shared by all editors
  1683.   ((indent-tokens '(define define-integrable macro case when apply set!
  1684.              lambda named-lambda rec let letrec let* fluid-let
  1685.              call-with-current-continuation call/cc
  1686.              with-input-from-file with-output-to-file
  1687.              call-with-input-file call-with-output-file
  1688.              autoload-from-file))
  1689.  
  1690.    (separators (string-append "()'`\"," 
  1691.                   ((make-color-editor 'EXIT-FREELY) 
  1692.                    'separators)))
  1693.  
  1694.    (tab-indent? (lambda (ed)
  1695.           (let* ((epos (ed 'position))
  1696.              (line (list-ref (ed 'buffer) (car epos))))
  1697.             (or (> (cadr epos) (string-length line))
  1698.             (= (cadr epos) 0)
  1699.             (substring-find-next-char-in-set 
  1700.               separators 0 (string-length separators)
  1701.               (string-ref line (-1+ (cadr epos))))))))
  1702.  
  1703.    (action-keys
  1704.      (append
  1705.        (list
  1706.      (cons (list*     001) '@mark-expr)        ; Ctrl-A
  1707.      (cons (list*     026) '@mark-def)        ; Ctrl-Z
  1708.      (cons (list*     009) (list* (cons tab-indent? '@indent) 
  1709.                       '@completion))    ; Indent || completion
  1710.      (cons (list*     013) '@scheme-enter)         ; Return && indent
  1711.          (cons (list*     041) '@scheme-parenthesis)    ; Electric parenthesis
  1712.      (cons (list* 015 000) '@comment)        ; Shift-tab
  1713.      (cons (list* 113 000) '@eval)            ; Alt-F10
  1714.      (cons (list* 103 000) '@eval-block)        ; Ctrl-F10
  1715.        )
  1716.        ((make-color-editor 'EXIT-FREELY) 'actions)))
  1717.   )
  1718.  
  1719.   (set! make-scheme-editor
  1720.     (lambda param
  1721.       (letrec
  1722.         (
  1723.          (ed (apply make-color-editor param))
  1724.  
  1725.          (ewin '())
  1726.          (epos '())
  1727.          (input-port '())
  1728.          (win #F)
  1729.          (nlin 0)
  1730.          (ncol 0)
  1731.          (clin 1)
  1732.          (ccol 0)
  1733.          (flin 1)
  1734.          (fcol 0)
  1735.          (draft-name "DRAFT$$$")
  1736.          (used draft-name)
  1737.          (comment-column 40)
  1738.  
  1739.               
  1740.    ; Help to inherit a fresh copy of current state variables           
  1741.            
  1742.          (get-values (lambda ()
  1743.        (set! input-port (ed 'input-port))
  1744.        (set! ewin (ed 'window))
  1745.        (set! win  (car  ewin))
  1746.        (set! nlin (cadr ewin))
  1747.        (set! ncol (cddr ewin))
  1748.        (set! epos (ed 'position))
  1749.        (set! clin (car epos))
  1750.        (set! ccol (cadr epos))
  1751.        (set! flin (caddr epos))
  1752.        (set! fcol (cadddr epos))
  1753.          ))
  1754.  
  1755.    ; Key handling
  1756.  
  1757.          (mark (lambda (end delta)
  1758.        (let* ((epos (ed 'position))
  1759.               (right (expression 'end (car end) (cadr end) delta))
  1760.               (left (expression 'start (car epos) (cadr epos) delta)))
  1761.          (ed 'select (list 'char (car right) (max 0 (-1+ (cadr right)))))
  1762.          (ed 'position left)
  1763.          (ed 'refresh-lines (car left) (1+ (car right))))))
  1764.  
  1765.          (@mark-expr (lambda ()
  1766.        (let ((blk (ed 'select)))
  1767.          (if (car blk)
  1768.              (mark (cdr blk) 2)
  1769.              (mark (ed 'position) 1)))))
  1770.  
  1771.          (@mark-def (lambda ()
  1772.        (let ((epos (ed 'position)))
  1773.          (mark epos (ed 'cursor-depth (car epos) (cadr epos))))))
  1774.  
  1775.          (@completion (lambda ()
  1776.        (get-values)
  1777.        (ed 'modified #T)
  1778.            (let* ((curr (list-tail (ed 'buffer) clin))
  1779.               (str (car curr))
  1780.                   (len (string-length str)))
  1781.              (when (>= len ccol)
  1782.            (let ((spc (substring-find-previous-char-in-set str 0 ccol separators)))
  1783.              (when (if (null? spc) #T (> ccol (1+ spc)))
  1784.                (let* ((mid ccol)
  1785.                   (end (substring str ccol len))
  1786.                       (sta (begin (ed '@word-left) (cadr (ed 'position))))
  1787.                   (beg (substring str 0 sta)))
  1788.                  ((named-lambda (loop)
  1789.                   (let ((fnd (pcs-recognize-symbol (substring (car curr) sta ccol) (- mid sta))))
  1790.                   (if (null? fnd) (set! fnd (substring str sta mid)))
  1791.                   (set-car! curr (string-append beg fnd end))
  1792.                   (set! ccol (+ sta (string-length fnd)))
  1793.                   (set-car! (cdr epos) ccol)
  1794.                   (ed 'position epos)
  1795.                   (ed 'refresh-line)
  1796.                   ((named-lambda (scan action)
  1797.                  (if (pair? action)
  1798.                  (if (eq? (cdar action) '@completion)
  1799.                      (loop)
  1800.                      (scan (cdr action)))
  1801.                  (if (eq? action '@completion)
  1802.                      (loop)
  1803.                      (ed 'handle-action action))))
  1804.                (ed 'read-action))
  1805.                 ))))))))
  1806.        (pcs-recognize-symbol 'done)
  1807.            ))
  1808.  
  1809.          (indentize (lambda (clin cind)
  1810.        (if (= clin 1)
  1811.            0
  1812.            (let* ((buffer (ed 'buffer))
  1813.               (color (ed 'cursor-depth (-1+ clin) 32000))
  1814.               (cstr (list-ref buffer clin))
  1815.               (cchar (if (< cind (string-length cstr))
  1816.                  (string-ref cstr cind)))
  1817.               (left (ed 'expression 'start (-1+ clin) 32000 1))
  1818.               (str (list-ref buffer (car left)))
  1819.               (len (string-length str))
  1820.               (sub (substring str (min (1+ (cadr left)) len) len))
  1821.               (p (open-input-string sub))
  1822.               (atom (read-atom p))
  1823.               (npos (get-file-position p))
  1824.               (next (read-atom p)))
  1825.          (cond ((memv color '(0 50))         0)
  1826.                ((eqv? cchar #\))        (cadr left))
  1827.                ((or (eof-object? next)
  1828.                 (memq atom indent-tokens))    (+ (cadr left) 2))
  1829.                ((equal? atom '(|(|))        (+ (cadr left) 1))
  1830.                (else                 (+ (cadr left) npos 2)))))))
  1831.  
  1832.          (indent-lines (lambda (start end)
  1833.        (do ((curr (list-tail (ed 'buffer) start) (cdr curr))
  1834.             (clin start (1+ clin))
  1835.             (pos 0))
  1836.            ((>= clin end) pos)
  1837.            (let ((cind (ed 'substring-skip (car curr) 0 
  1838.                    (string-length (car curr)))))
  1839.          (set! pos (indentize clin cind))
  1840.          (set-car! curr
  1841.                (string-append 
  1842.                  (ed 'make-blank pos)
  1843.                  (substring (car curr) cind
  1844.                     (string-length (car curr))))))
  1845.            (ed 'refresh-lines clin (1+ clin)))))
  1846.  
  1847.          (@indent (lambda ()
  1848.        (let* ((blk (ed 'select))
  1849.               (blin (cadr blk))
  1850.               (clin (car (ed 'position))))
  1851.          (if (car blk)
  1852.          (indent-lines (min blin clin) (1+ (max blin clin)))
  1853.          (ed 'position 
  1854.              (list clin (indent-lines clin (1+ clin))))))))
  1855.  
  1856.          (@scheme-enter (lambda ()
  1857.        (ed '@enter)
  1858.        (ed '@indent)))
  1859.  
  1860.      (@scheme-parenthesis (lambda ()
  1861.        (get-values)
  1862.        (ed 'handle-action #\))
  1863.        (let* ((curr (list-tail (ed 'buffer) clin))
  1864.           (len (string-length (car curr)))
  1865.           (pos (expression 'start clin ccol 1))
  1866.           (str (list-ref (ed 'buffer) (car pos)))
  1867.           (width (ed 'with-status
  1868.                (lambda (mes)
  1869.                  (min (-1+ (cdr (window-get-size mes)))
  1870.                   (string-length str))))))
  1871.          (when (= ccol (ed 'substring-skip (car curr) 0 len))
  1872.            (indent-lines clin (1+ clin))
  1873.            (let ((diff (- len (string-length (car curr)))))
  1874.          (if (not (zero? diff))
  1875.              (ed 'position (list clin (- ccol diff -1))))))
  1876.          (ed 'notify (substring str (cadr pos) width)))))
  1877.  
  1878.          (@comment (lambda ()
  1879.        (get-values)
  1880.        (ed 'modified #T)
  1881.            (let* ((curr (list-tail (ed 'buffer) clin))
  1882.               (str (car curr))
  1883.                   (len (string-length str)))
  1884.              (when (< len comment-column)
  1885.            (set! str (string-append str (ed 'make-blank (- comment-column len)))))
  1886.          (set-car! curr (string-append str "; "))
  1887.          (set-car! (cdr epos) (+ 2 (max len comment-column)))
  1888.          (ed 'position epos)
  1889.          (ed 'refresh-line))))
  1890.  
  1891.          (@eval (lambda ()
  1892.        (let ((l   (reverse! (filename-split draft-name)))
  1893.              (ext (cadddr (filename-split (ed 'name)))))
  1894.          (if (ed 'modified)
  1895.              (begin
  1896.            (set! used (cons #T (filename-merge
  1897.                      (reverse! (cons ext (cdr l))))))
  1898.            (ed 'save (cdr used)))
  1899.              (set! used (cons #F (ed 'name))))
  1900.          (ed 'todo 'eval)
  1901.          )))
  1902.  
  1903.          (@eval-block (lambda ()
  1904.        (let ((l   (reverse! (filename-split draft-name)))
  1905.              (ext (cadddr (filename-split (ed 'name)))))
  1906.          (set! used (cons #T (filename-merge
  1907.                    (reverse! (cons ext (cdr l))))))
  1908.          (ed 'write-block (cdr used))
  1909.          (ed 'todo 'eval)
  1910.          )))
  1911.  
  1912.    ; Interface support
  1913.  
  1914.          (deepize (lambda (str clin)
  1915.        (let* ((p (open-input-string str))
  1916.  
  1917.               (scan (named-lambda (scan p curpos curcol carry res low)
  1918.             (let* ((atom (read-atom p))
  1919.                (now (if (equal? atom '(|(|)) 
  1920.                     (1+ (or carry 0))
  1921.                     carry))
  1922.                (low (if carry (min low (+ carry curcol)) low))
  1923.                (nxt (if (equal? atom '(|)|)) -1)))
  1924.               (cond
  1925.                 ((eof-object? atom) 
  1926.                  (let* ((endres (+ (or now 0) (if res (caar res) 0)))
  1927.                     (endcol (cons 0 (cons endres low)))
  1928.                     (comment 
  1929.                       (substring-find-next-char-in-set 
  1930.                     str curpos (string-length str) #\;)))
  1931.                (if comment 
  1932.                    (cons endcol (reverse! 
  1933.                           (cons (cons (+ endres 50) 
  1934.                                   comment)
  1935.                             res)))
  1936.                    (cons endcol (reverse! res)))))
  1937.                 (now (scan p (get-file-position p) 
  1938.                    (+ curcol now) nxt
  1939.                    (cons (cons (+ curcol now) curpos) res) low))
  1940.                 (else (scan p (get-file-position p) curcol nxt res low))))))
  1941.  
  1942.             (deep (scan p 0 0 #f '() 0)))
  1943.  
  1944.          (if (and (not (null? (cdr deep)))
  1945.               (= (cdadr deep) 0))
  1946.              (begin (set-cdr! (cadr deep) (cdar deep)) (cdr deep))
  1947.              deep))
  1948.        ))
  1949.  
  1950.          (cdepth (lambda (clin ccol left right base)
  1951.        (let ((line (list-ref (ed 'buffer) clin)))
  1952.          (if (< ccol (string-length line))
  1953.            (let* ((p (open-input-string (substring line (1+ ccol) (cdar right))))
  1954.               (corr (if (equal? (read-atom p) '(|(|)) -1 0)))
  1955.              (+ base (caar left) corr))
  1956.            (ed 'line-depth (1+ clin))))))
  1957.  
  1958.          (cursor-depth (lambda (clin ccol)    ; more precise than cursor-color...
  1959.        (let* ((left (ed 'left-colors clin ccol)); bcoz between (A) (C) no color change
  1960.               (right (ed 'right-colors clin ccol))
  1961.               (base (ed 'line-depth clin)))
  1962.          (cdepth clin ccol left right base))))
  1963.  
  1964.  
  1965.          (expression (lambda (dir clin ccol delta)
  1966.        (let* ((fwd (eq? dir 'end))
  1967.               (left (ed 'left-colors clin ccol))
  1968.               (right (ed 'right-colors clin ccol))
  1969.               (base (ed 'line-depth clin))
  1970.               (color (cdepth clin ccol left right base))
  1971.               (buffer (ed 'buffer)))
  1972.          (letrec
  1973.            ((fpar (lambda (clin pos)
  1974.               (let ((str (list-ref buffer clin)))
  1975.             (list clin
  1976.                   (substring-find-next-char-in-set
  1977.                 str pos (string-length str) #\()))))
  1978.  
  1979.             (locate (lambda (color deep)
  1980.               (if (and (cdr deep)
  1981.                (or (and (= (1+ color) (caar deep))
  1982.                     (= (1+ color) (caadr deep))
  1983.                     (or (not fwd) (cddr deep)))
  1984.                    (= color (caadr deep))))
  1985.               ((if fwd cdadr cdar) deep)
  1986.               (if (cddr deep) (locate color (cdr deep))))))
  1987.  
  1988.             (in-line (lambda (clin)
  1989.               (let* ((deep (if fwd 
  1990.                    (ed 'right-colors clin 0)
  1991.                    (ed 'left-colors clin 32000)))
  1992.                  (base (ed 'line-depth clin))
  1993.                  (diff (- color delta base))
  1994.                  (pos (cond 
  1995.                     ((and fwd (= diff 0)) 0)
  1996.                     ((and fwd (= diff (caar deep))) (cdar deep))
  1997.                     ((null? (cdr deep)) 0)
  1998.                     (else (locate (- color base delta) deep)))))
  1999.             ((if fwd list fpar) clin pos))))
  2000.  
  2001.             (deep-scan (lambda (color flor dist)
  2002.               (if (>= color 0)
  2003.                   (deep-scan (-1+ color) flor 
  2004.                      (max dist (length (memv color flor))))
  2005.               (in-line (-1+ dist)))))
  2006.  
  2007.             (wide-scan (lambda (color nlin)
  2008.               (if (<= (ed 'line-floor nlin) color)
  2009.                   (in-line (-1+ nlin))
  2010.                   (if (< nlin (length buffer))
  2011.                   (wide-scan color (1+ nlin))))))
  2012.  
  2013.             (pos (locate (- color base delta) 
  2014.                  (if fwd (cons (car left) right) left))))
  2015.  
  2016.            (if fwd
  2017.              (cond ((>= color 50) (list clin (cdar right)))
  2018.                ((< color delta) (list (-1+ (length buffer)) 
  2019.                           (string-length (car (last-pair buffer)))))
  2020.                (pos (list clin pos))
  2021.                (else (wide-scan (- color delta) (+ clin 2))))
  2022.              (cond ((>= color 50) (list clin (cdar left)))
  2023.                ((< color delta) (list 1 0))
  2024.                (pos (fpar clin pos))
  2025.                (else (let* ((flor (ed 'upper-floor))
  2026.                     (len (length flor)))
  2027.                    (deep-scan (- color delta)
  2028.                           (list-tail flor (- len clin))
  2029.                           0)))))))
  2030.        ))
  2031.  
  2032.  
  2033.            
  2034.    ; Message handling
  2035.  
  2036.          (jobs (append
  2037.        (list
  2038.                 (cons '@mark-expr            @mark-expr)
  2039.              (cons '@mark-def            @mark-def) 
  2040.          (cons '@indent            @indent)
  2041.          (cons '@completion            @completion)
  2042.              (cons '@scheme-enter        @scheme-enter)    
  2043.          (cons '@scheme-parenthesis        @scheme-parenthesis)
  2044.              (cons '@comment            @comment)  
  2045.              (cons '@eval            @eval)
  2046.              (cons '@eval-block            @eval-block)
  2047.          (cons 'cursor-depth cursor-depth)    ; variant to cursor-color
  2048.          (cons 'expression expression)        ; seek expression bounds
  2049.          (cons 'indent-lines indent-lines)    ; indent a pack of lines
  2050.              (cons 'draft-name               (lambda l (begin0 draft-name (if l (set! draft-name (car l))))))
  2051.          (cons 'comment-column        (lambda l (begin0 comment-column (if l (set! comment-column (car l))))))
  2052.          (cons 'indent-tokens        (lambda l (begin0 indent-tokens (if l (set! indent-tokens (car l))))))
  2053.          (cons 'indentize               (lambda l (begin0 indentize (if l (set! indentize (car l))))))
  2054.          )            
  2055.        (ed 'jobs)))
  2056.  
  2057.          (me (lambda args
  2058.            (let ((todo (apply ed args)))
  2059.              (case todo
  2060.                   ('eval (load (cdr used)) 
  2061.               (if (car used) (dos-delete (cdr used))) 
  2062.               *the-non-printing-object*)
  2063.            (else  todo)))))
  2064.  
  2065.         ) ; LETREC bindings
  2066.  
  2067.     (ed 'separators separators)    ; initialization
  2068.         (ed 'actions    action-keys)
  2069.         (ed 'jobs       jobs)
  2070.         (ed 'deepize    deepize)
  2071.         (ed 'who        me)
  2072.         me
  2073.  
  2074.       )   ; LETREC
  2075.     )    ; LAMBDA param
  2076.   )   ; SET! make-editor
  2077. )   ; LET
  2078.  
  2079.  
  2080. ;**************************************************************************
  2081. ; Finally, this is the EXIT handler to avoid quitting without saving
  2082.  
  2083. (let ((pcs-exit (access exit user-global-environment))
  2084.       (editors  '()))
  2085.  
  2086.   (set! editor-handle-exit (lambda (it . ed)
  2087.     (cond
  2088.       ((eq? it 'remember) (set! editors (cons (car ed) editors)))
  2089.       ((eq? it 'forget)      (set! editors (delq! (car ed) editors)))
  2090.       ((eq? it 'get-list) editors)
  2091.       (else (%error-invalid-operand 'editor-handle-exit it)))))
  2092.  
  2093.   (set!
  2094.     (access exit user-global-environment)
  2095.     (lambda args
  2096.       (if args
  2097.       (apply pcs-exit args)
  2098.       ((named-lambda (loop editors)
  2099.          (if (null? editors)
  2100.          (pcs-exit)
  2101.          (if ((car editors) 'safe)
  2102.              (loop (cdr editors))))) editors))
  2103.       (writeln "EXIT canceled on user request."))))
  2104.